home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1999 April / macformat-075.iso / Shareware Plus / Applications / Alpha / Tcl / SystemCode / CorePackages / www.tcl < prev   
Encoding:
Text File  |  1999-02-02  |  7.5 KB  |  251 lines  |  [TEXT/ALFA]
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  Alpha - new Tcl folder configuration
  4.  # 
  5.  #  FILE: "www.tcl"
  6.  #                                    created: 4/9/97 {11:37:57 am} 
  7.  #                                last update: 2/2/1999 {1:09:40 pm} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: <darley@fas.harvard.edu>
  10.  #    mail: Division of Engineering and Applied Sciences, Harvard University
  11.  #          Oxford Street, Cambridge MA 02138, USA
  12.  #     www: <http://www.fas.harvard.edu/~darley/>
  13.  #  
  14.  #  modified by  rev reason
  15.  #  -------- --- --- -----------
  16.  #  4/9/97   VMD 1.0 original
  17.  # ###################################################################
  18.  ##
  19.  
  20. namespace eval url {}
  21.  
  22. proc url::parse {url} {
  23.     if {![regexp {^([^:]+)://(.*)$} $url dmy type rest]} {
  24.     alertnote "I couldn't understand that url: '$url'"
  25.     error ""
  26.     }
  27.     return [list $type $rest]
  28. }
  29.  
  30. proc url::parseFtp {p array} {
  31.     # format is user:pass@host/path
  32.     if {[set at [string first "@" $p]] != -1} {
  33.     # have user etc.
  34.     if {[string first ":" $p] < $at} {
  35.         # have password
  36.         regexp {([^:]+):([^@]+)@(.*)$} $p dummy user pass p
  37.     } else {
  38.         # no password
  39.         regexp {([^@]+)@(.*)$} dummy user p
  40.         set pass ""
  41.     }
  42.     } else {
  43.     set user "anonymous"
  44.     set pass [icGetPref Email]
  45.     }
  46.     regexp {([^/]+)($|/$|/(.*/)([^/]*)$)} $p dummy host dummy path file
  47.     upvar $array a
  48.     array set a [list user $user pass $pass host $host path $path file $file]
  49. }
  50.  
  51. proc url::store {url file} {
  52.     set t [url::parse $url]
  53.     set type [lindex $t 0]
  54.     set rest [lindex $t 1]    
  55.     switch -- $type {
  56.     "ftp" {
  57.         url::parseFtp $rest i
  58.         set i(file) [file tail $file]
  59.         ftpStore "$file" $i(host) "$i(path)$i(file)" $i(user) $i(pass)
  60.     }
  61.     default {
  62.         alertnote "Don't know how to put '$type' url's"
  63.         error ""
  64.     }
  65.     }
  66. }
  67.  
  68. proc url::fetchFrom {url localdir {file ""}} {
  69.     url::fetch ${url}${file} $localdir $file    
  70. }
  71.  
  72.  
  73. ## 
  74.  # -------------------------------------------------------------------------
  75.  # 
  76.  # "url::fetch" --
  77.  # 
  78.  #  Get a precise url into a localdir/file.  The url may be a directory,
  79.  #  in which case we retrieve a listing.
  80.  #  
  81.  #  Use url::fetchFrom to fetch a file from a given url-location.
  82.  #  
  83.  #  Note 'Geni' is the sig of a wish applet I wrote which is augmented
  84.  #  with a few procedures to download files via http. 
  85.  #  Of course it needs the user to install Sun's latest
  86.  #  release of Tcl/Tk
  87.  # -------------------------------------------------------------------------
  88.  ##
  89. proc url::fetch {url localdir {file ""}} {
  90.     set t [url::parse $url]
  91.     set type [lindex $t 0]
  92.     set rest [lindex $t 1]
  93.     switch -- $type {
  94.     "ftp" {
  95.         url::parseFtp $rest i
  96.         catch {mkdir [file dirname $localdir]}
  97.         if {[regexp "/$" "$i(path)$i(file)"]} {
  98.         # directory
  99.         ftpList $localdir$file $i(host) $i(path) $i(user) $i(pass)
  100.         } else {
  101.         ftpFetch "$localdir$file" $i(host) "$i(path)$i(file)" $i(user) $i(pass)
  102.         }
  103.     }
  104.     "http" {
  105.         global httpDownloadSig httpDownloadSigs
  106.         url::parseFtp $rest i
  107.         app::launchAnyOfThese $httpDownloadSigs httpDownloadSig
  108.         if {[file exists "$localdir$file"]} {
  109.         if {[dialog::yesno "Replace $file?"]} {
  110.             file delete "$localdir$file"
  111.         } else {
  112.             error "Abort download."
  113.         }
  114.         }
  115.         set fid [open "$localdir$file" w]
  116.         close $fid
  117.         if {$httpDownloadSig == "Geni"} {
  118.         switchTo '$httpDownloadSig'
  119.         set res [AEBuild -r -t 30000 '$httpDownloadSig' misc dosc ---- \
  120.           "“[list Http_Copy ${url} $localdir$file]”"]
  121.         switchTo 'ALFA'
  122.         if {[string match "*Not found*" $res]} {
  123.             catch {file delete $localdir$file}
  124.             error "File not found on http server."
  125.         }
  126.         } else {
  127.         AEBuild -r -t 30000 '$httpDownloadSig' WWW! OURL ---- "“${url}”" \
  128.           INTO [makeAlis "$localdir$file"]
  129.         }
  130.     }
  131.     default {
  132.         alertnote "Don't know how to fetch '$type' url's"
  133.         error ""
  134.     }
  135.     }
  136.     return $type
  137. }
  138.  
  139. ## 
  140.  # -------------------------------------------------------------------------
  141.  # 
  142.  # "ftpFetch" --
  143.  # 
  144.  #  Downloads a remote file to your disk. 
  145.  #  
  146.  # -------------------------------------------------------------------------
  147.  ##
  148. proc ftpFetch {localName host path user password} {
  149.     global ftpSig ftpSigs
  150.     watchCursor
  151.     app::launchAnyOfThese $ftpSigs ftpSig "Please locate your ftp application:"
  152.     if {$ftpSig == "FTCh"} {
  153.     set localName "[file dirname $localName]:"
  154.     } else {
  155.     set fd [open $localName "w"]
  156.     close $fd
  157.     }
  158.     switch -- $ftpSig {
  159.     Arch -
  160.     FTCh {AEBuild -r -t 30000 '$ftpSig' Arch Ftch FTPh "“$host”" FTPc "“$path”" ArGU "“$user”" ArGp "“$password”" ---- [makeAlis $localName]}
  161.     Woof {AEBuild -r -t 30000 'Woof' GURL GURL ---- "“ftp://${user}:${password}@${host}/${path}”" dest [makeAlis $localName]}
  162.     }
  163. }
  164.  
  165. ## 
  166.  # -------------------------------------------------------------------------
  167.  # 
  168.  # "ftpStore" --
  169.  # 
  170.  #  Uploads a file to a remote ftp server.
  171.  #  
  172.  # -------------------------------------------------------------------------
  173.  ##
  174. proc ftpStore {localName host path user password} {
  175.     global ftpSig ftpSigs
  176.     watchCursor
  177.     app::launchAnyOfThese $ftpSigs ftpSig "Please locate your ftp application:"
  178.     currentReplyHandler ftpHandleReply
  179.     switch -- $ftpSig {
  180.     Arch -
  181.     FTCh {AEBuild -q -t 30000 '$ftpSig' Arch Stor ---- [makeAlis $localName] FTPh "“$host”" FTPc "“$path”" ArGU "“$user”" ArGp "“$password”"}
  182.     Woof {
  183.         set path [string range $path 0 [expr {[string last / $path] - 1}]]
  184.         AEBuild -r -q -t 30000 '$ftpSig' PURL PURL ---- [makeAlis $localName] dest "“ftp://${user}:${password}@${host}/${path}”"
  185.     }
  186.     }
  187. }
  188.  
  189. ## 
  190.  # -------------------------------------------------------------------------
  191.  # 
  192.  # "ftpList" --
  193.  # 
  194.  #  Saves the file listing of a remote directory to a file. Uses a trick 
  195.  #  for Fetch when saving the file. First the files are listed in a text
  196.  #  window in Fetch. This window is then saved to the disk.
  197.  #  
  198.  #  This function doesn't work with NetFinder.
  199.  #   
  200.  # -------------------------------------------------------------------------
  201.  ##
  202. proc ftpList {localName host path user password} {
  203.     global ftpSig
  204.     watchCursor
  205.     app::launchAnyOfThese [list Arch FTCh] ftpSig "Please locate your ftp application:"
  206.     if {[lsearch {Arch FTCh} $ftpSig] < 0} {alertnote "This only works with Anarchie and Fetch."; error ""}
  207.     set fd [open $localName "w"]
  208.     close $fd
  209.     AEBuild -r -t 30000 '$ftpSig' Arch List FTPh "“$host”" FTPc "“$path”" ArGU "“$user”" ArGp "“$password”" {----} [makeAlis $localName]
  210.     if {$ftpSig == "FTCh"} {
  211.         AEBuild -r -t 30000 'FTCh' FTCh VwFL ---- "obj{want:type(cFWA), from:'null'(), form:name, seld:“$host”}"
  212.         AEBuild -r -t 30000 'FTCh' core save ---- "obj{want:type(cFWC), from:'null'(), form:indx, seld:long(1)}" kfil [makeAlis $localName]
  213.         AEBuild -r -t 30000 'FTCh' core clos ---- "obj{want:type(cFWC), from:'null'(), form:indx, seld:long(1)}" savo "yes"
  214.      }
  215. }
  216.  
  217.  
  218. ## 
  219.  # -------------------------------------------------------------------------
  220.  # 
  221.  # "ftpHandleReply" --
  222.  # 
  223.  #  Handles the reply when using ftpStore.
  224.  #  
  225.  # -------------------------------------------------------------------------
  226.  ##
  227. proc ftpHandleReply {reply} {
  228.     set ans [string range $reply 11 end]
  229.     if {[regexp {^errs:“([^”]+)”} $ans dum err]} {
  230.         # Fetch error
  231.         if {[regexp {Error: (.*)} $err dum err2]} {set err $err2}
  232.         alertnote "Ftp error: $err"
  233.     } elseif {[regexp {^'----':(-?[0-9]*)} $ans dum err]} {
  234.         if {$err != "0"} {
  235.             # Anarchie error.
  236.             message "Ftp error."
  237.         } else {
  238.             message "Document uploaded to ftp server."
  239.         }
  240.     } elseif {$ans == "\\\}"} {
  241.         message "Document uploaded to ftp server."
  242.     } else {
  243.         return 0
  244.     }
  245.     return 1
  246. }
  247.  
  248.  
  249.  
  250.  
  251.